home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 1 / Gold Medal Software Volume 1 (Gold Medal) (1994).iso / prog / tpwprog7.arj / GETBITS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-07-02  |  4.8 KB  |  181 lines
  1. { getbits.pas -- Retrieve bitmap (if present) from clipboard }
  2.  
  3. program GetBits;
  4.  
  5. {$R getbits.res}
  6.  
  7. uses WinTypes, WinProcs, WObjects;
  8.  
  9. const
  10.  
  11.   id_Menu  = 100;    { Menu resource ID }
  12.   cm_Quit  = 101;    { Exit command ID }
  13.   cm_Paste = 201;    { Paste command ID }
  14.   cm_Clear = 202;    { Clear command ID }
  15.  
  16. type
  17.  
  18.   GetBitsApplication = object(TApplication)
  19.     procedure InitMainWindow; virtual;
  20.   end;
  21.  
  22.   PGetBitsWindow = ^GetBitsWindow;
  23.   GetBitsWindow = object(TWindow)
  24.     Bitmap: HBitmap;
  25.     Width, Height: LongInt; { Size of bitmap image }
  26.     HTheMenu: HMenu;  { Handle to menu with Paste command }
  27.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  28.     destructor Done; virtual;
  29.     procedure DestroyBitmap;
  30.     procedure Paint(PaintDC: HDC;
  31.       var PaintInfo: TPaintStruct); virtual;
  32.     procedure WMInitMenuPopup(var Msg: TMessage);
  33.       virtual wm_First + wm_InitMenuPopup;
  34.     procedure CMQuit(var Msg: TMessage);
  35.       virtual cm_First + cm_Quit;
  36.     procedure CMPaste(var Msg: TMessage);
  37.       virtual cm_First + cm_Paste;
  38.     procedure CMClear(var Msg: TMessage);
  39.       virtual cm_First + cm_Clear;
  40.   end;
  41.  
  42.  
  43. { GetBitsApplication }
  44.  
  45. {- Initialize GetBitsApplication object's window }
  46. procedure GetBitsApplication.InitMainWindow;
  47. begin
  48.   MainWindow := New(PGetBitsWindow, Init(nil, 'Get Bitmap'))
  49. end;
  50.  
  51.  
  52. { GetBitsWindow }
  53.  
  54. {- Construct GetBitsWindow object }
  55. constructor GetBitsWindow.Init(AParent: PWindowsObject; ATitle: PChar);
  56. begin
  57.   TWindow.Init(AParent, ATitle);
  58.   Attr.Menu := LoadMenu(HInstance, PChar(id_Menu));
  59.   HTheMenu := GetSubMenu(Attr.Menu, 1);  { Handle to "Bitmap" menu }
  60.   Bitmap := 0
  61. end;
  62.  
  63. {- Destroy GetBitsWindow }
  64. destructor GetBitsWindow.Done;
  65. begin
  66.   DestroyBitmap;
  67.   TWindow.Done
  68. end;
  69.  
  70. {- Destroy window's bitmap if present }
  71. procedure GetBitsWindow.DestroyBitmap;
  72. begin
  73.   if Bitmap <> 0 then
  74.   begin
  75.     DeleteObject(Bitmap);
  76.     Bitmap := 0
  77.   end
  78. end;
  79.  
  80. {- Enable or disable paste and clear commands }
  81. procedure GetBitsWindow.WMInitMenuPopup(var Msg: TMessage);
  82. begin
  83.   if Msg.WParam = HTheMenu then
  84.   begin
  85.     EnableMenuItem(HTheMenu, cm_Paste, mf_ByCommand or mf_Grayed);
  86.     if Bitmap <> 0 then
  87.       EnableMenuItem(HTheMenu, cm_Clear, mf_ByCommand or mf_Enabled)
  88.     else
  89.       EnableMenuItem(HTheMenu, cm_Clear, mf_ByCommand or mf_Grayed);
  90.     if OpenClipboard(HWindow) then
  91.     begin
  92.       if IsClipboardFormatAvailable(cf_Bitmap) then
  93.         EnableMenuItem(HTheMenu, cm_Paste, mf_ByCommand or mf_Enabled);
  94.       CloseClipboard
  95.     end
  96.   end
  97. end;
  98.  
  99. {- Exit application }
  100. procedure GetBitsWindow.CMQuit(var Msg: TMessage);
  101. begin
  102.   CloseWindow
  103. end;
  104.  
  105. {- Paste bitmap from clipboard into window }
  106. procedure GetBitsWindow.CMPaste(var Msg: TMessage);
  107. var
  108.   HClip: THandle;                 { Handle to clipboard data }
  109.   HPtr: Pointer;                  { Pointer to locked data }
  110.   DC, MemDC1, MemDC2: HDC;        { Display context handles }
  111.   OldBits1, OldBits2: HBitmap;    { Handles to old DC bitmaps }
  112.   BitmapRec: TBitmap;             { Bitmap info record }
  113. begin
  114.   DestroyBitmap;
  115.   if OpenClipboard(HWindow) then
  116.   begin
  117.     HClip := GetClipboardData(cf_Bitmap);
  118.     if HClip <> 0 then
  119.     begin
  120.       DC := GetDC(HWindow);
  121.       MemDC1 := CreateCompatibleDC(DC);
  122.       MemDC2 := CreateCompatibleDC(DC);
  123.       GetObject(HClip, Sizeof(TBitmap), @BitmapRec);
  124.       Width := BitmapRec.BMWidth;
  125.       Height := BitmapRec.BMHeight;
  126.       Bitmap := CreateCompatibleBitmap(DC, Width, Height);
  127.       OldBits1 := SelectObject(MemDC1, HClip);
  128.       OldBits2 := SelectObject(MemDC2, Bitmap);
  129.       BitBlt(MemDC2, 0, 0, Width, Height, MemDC1, 0, 0, SrcCopy);
  130.       SelectObject(MemDC1, OldBits1);
  131.       SelectObject(MemDC2, OldBits2);
  132.       DeleteDC(MemDC1);
  133.       DeleteDC(MemDC2);
  134.       ReleaseDC(HWindow, DC)
  135.     end;
  136.     CloseClipboard
  137.   end;
  138.   InvalidateRect(HWindow, nil, true)
  139. end;
  140.  
  141. {- Clear window contents }
  142. procedure GetBitsWindow.CMClear(var Msg: TMessage);
  143. begin
  144.   DestroyBitmap;
  145.   InvalidateRect(HWindow, nil, true)
  146. end;
  147.  
  148. {- Paint bitmap inside window }
  149. procedure GetBitsWindow.Paint(PaintDC: HDC;
  150.   var PaintInfo: TPaintStruct);
  151. var
  152.   MemDC: HDC;
  153.   OldBitmap: HBitmap;
  154. begin
  155.   TWindow.Paint(PaintDC, PaintInfo);
  156.   if Bitmap <> 0 then
  157.   begin
  158.     MemDC := CreateCompatibleDC(PaintDC);
  159.     OldBitmap := SelectObject(MemDC, Bitmap);
  160.     BitBlt(PaintDC, 10, 10, Width, Height, MemDC, 0, 0, SRCCopy);
  161.     SelectObject(MemDC, OldBitmap);
  162.     DeleteDC(MemDC)
  163.   end
  164. end;
  165.  
  166. var
  167.  
  168.   GetBitsApp: GetBitsApplication;
  169.  
  170. begin
  171.   GetBitsApp.Init('GetBitsApp');
  172.   GetBitsApp.Run;
  173.   GetBitsApp.Done
  174. end.
  175.  
  176.  
  177. {--------------------------------------------------------------
  178.   Copyright (c) 1991 by Tom Swan. All rights reserved.
  179.   Revision 1.00    Date: 5/26/1991
  180. ---------------------------------------------------------------}
  181.